home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / ezwind.arc / EZWIND.PAS
Pascal/Delphi Source File  |  1986-03-09  |  9KB  |  385 lines
  1. { EZWIND.PAS }
  2.  
  3. { Collection of screen I/O routines  }
  4.  
  5.  
  6. { Written by Bill Bliss, 76474,154   }
  7. { Uploaded to CompuServe on 2-10-86  }
  8.  
  9. {  These routines contain some routines for directly writing to screen
  10.    memory in Turbo Pascal.
  11.  
  12.    Although they have not been optimized for speed, they do utilize a
  13.    model for screen memory that is extremely readable and provides for
  14.    easy debugging.
  15.  
  16.    There is also a rudimentary level of window support; i.e. one window
  17.    on the screen at one time.  The method used for saving the screen is
  18.    not memory efficient, either; the routines essentially reserve a 4K
  19.    buffer that is a copy of the screen.  This is partially because it is
  20.    easy, but partially because I developed these routines for other
  21.    purposes besides this!
  22.  
  23.    Also, realize that originally these routines took advantage of the
  24.    procedures MoveToScreen and MoveFromScreen found in Borland's Turbo
  25.    Editor Toolbox which avoid snow on the IBM C/G adapter.  For obvious
  26.    reasons, these routines do not include that code.  I rewrote them
  27.    into empty shells which now do a simple Turbo Move.
  28.  
  29.    Also, when I was working with the Editor routines, I found that there
  30.    was a slight bug; you could not move data in and out of memory in one
  31.    byte increments.  Hence, I had to kludge a little to get around this.
  32.    I probably could've rewritten the Editor routines, but I didn't feel
  33.    like it at the time!
  34.  
  35.    These routines WILL cause snow on the IBM C/G adapter and Hercules C/G
  36.    adapter, but will NOT cause snow on the IBM Mono adapter, Zenith C/G
  37.    adapter, or IBM EGA.  Other systems have not been tested.
  38.  
  39.    These routines should work with any IBM PC/Compatible, and although I
  40.    haven't tested it, with Turbo 2.0 or above.  They definitely work with
  41.    3.01A, though.
  42.  
  43.    These routines are rather sparsely documented, so if you have any questions
  44.    please contact me!.
  45.  
  46.                                                      }
  47.  
  48.  
  49. type
  50.   RegPack = record
  51.               AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS : integer
  52.             end;
  53.   AnyStr = string[255];
  54.  
  55. const
  56.   DefBGColor : byte = blue;
  57.  
  58. type
  59.   VideoModes = (CGA,MONO,PCjr,EGA);
  60.   ScrChar = record
  61.               ScrChar : char;
  62.               Attr : byte
  63.             end;
  64.   ScreenBuf = array[1..25,1..80] of ScrChar;
  65.   ScreenBufPtr = ^ScreenBuf;
  66.  
  67. var
  68.   VideoSeg,TempScreen : ScreenBufPtr;
  69.   TempAttr,OldX,OldY : byte;
  70.  
  71.  
  72. function VideoMode : VideoModes;
  73.  
  74. var
  75.   Registers : RegPack;
  76.  
  77. begin
  78.   Registers.AX := $0F00;
  79.   Intr($10,Registers);
  80.   case Lo(Registers.AX) of
  81.      0..6 : VideoMode := CGA;
  82.         7 : VideoMode := MONO;
  83.       8,9 : VideoMode := PCjr;
  84.    10..15 : VideoMode := EGA
  85.   end
  86. end;
  87.  
  88.  
  89. procedure MoveToScreen(Var Source,Dest; Length: Integer);
  90.  
  91. begin
  92.   Move(Source,Dest,Length)
  93. end;
  94.  
  95.  
  96. procedure MoveFromScreen(Var Source,Dest; Length: Integer);
  97.  
  98. begin
  99.   Move(Source,Dest,Length)
  100. end;
  101.  
  102.  
  103. procedure CursorOff;
  104.  
  105. var
  106.   Registers : RegPack;
  107.  
  108. begin
  109.   Registers.AX := $0300;
  110.   Registers.BX := 0;
  111.   Intr($10,Registers);
  112.   Registers.CX := Registers.CX or $2000;
  113.   Registers.AX := $0100;
  114.   Intr($10,Registers)
  115. end;
  116.  
  117.  
  118. procedure CursorOn;
  119.  
  120. var
  121.   Registers : RegPack;
  122.  
  123. begin
  124.   Registers.AX := $0300;
  125.   Registers.BX := 0;
  126.   Intr($10,Registers);
  127.   Registers.CX := Registers.CX and $DFFF;
  128.   Registers.AX := $0100;
  129.   Intr($10,Registers)
  130. end;
  131.  
  132.  
  133. procedure GetVideoSegment;
  134.  
  135. begin
  136.   if VideoMode = MONO then
  137.     VideoSeg := Ptr($B000,0)
  138.   else
  139.     VideoSeg := Ptr($B800,0)
  140. end;
  141.  
  142.  
  143. function ComputeAttr(FC,BC : byte) : byte;
  144.  
  145. begin
  146.   if FC >= Blink then
  147.     ComputeAttr := ((BC shl 4) + (FC - Blink)) or $80
  148.   else
  149.     ComputeAttr := ((BC shl 4) + FC) and $7F
  150. end;
  151.  
  152.  
  153. procedure WriteAt(p : ScreenBufPtr;
  154.                   x,y : byte;
  155.                   ch : char;
  156.                   Attr : byte);
  157.  
  158. var
  159.   j : integer;
  160.  
  161. begin
  162.   j := (Attr shl 8) + byte(ch);
  163.   MoveToScreen(j,p^[x,y],2)
  164. end;
  165.  
  166.  
  167. procedure ClearBuf(p : ScreenBufPtr);
  168.  
  169. begin
  170.   FillChar(p^,4000,0)
  171. end;
  172.  
  173.  
  174. procedure WriteStrAt(p : ScreenBufPtr;
  175.                      x,y : byte;
  176.                      S : AnyStr;
  177.                      FG,BG,HFG,HBG : byte);
  178.  
  179. var
  180.   i,j : byte;
  181.   NormAttr,HiAttr : byte;
  182.  
  183. begin
  184.   i := 0;
  185.   j := 0;
  186.   NormAttr := ComputeAttr(FG,BG);
  187.   HiAttr := ComputeAttr(HFG,HBG);
  188.   repeat
  189.     i := i+1;
  190.     if S[i] = '~' then
  191.       repeat
  192.         i := i+1;
  193.         if S[i] <> '~' then
  194.           begin
  195.             WriteAt(p,x,y+j,S[i],HiAttr);
  196.             j := j+1
  197.           end
  198.       until S[i] = '~'
  199.     else
  200.       begin
  201.         WriteAt(p,x,y+j,S[i],NormAttr);
  202.         j := j+1
  203.       end
  204.   until (i = Length(S)) or (y+j = 80)
  205. end;
  206.  
  207.  
  208. procedure CenterStrAt(p : ScreenBufPtr;
  209.                       x : byte;
  210.                       S : AnyStr;
  211.                       FG,BG,HFG,HBG : byte);
  212. var
  213.   i,j : byte;
  214.  
  215. begin
  216.   j := 0;
  217.   for i := 1 to Length(S) do
  218.     if S[i] = '~' then
  219.       j := j+1;
  220.   i := (80 - Length(S) + j) div 2;
  221.   WriteStrAt(p,x,i,S,FG,BG,HFG,HBG)
  222. end;
  223.  
  224.  
  225. procedure HiLiteBar(p : ScreenBufPtr;
  226.                     row,col,width,HFC,HBC : byte);
  227.  
  228. var
  229.   i : byte;
  230.   j : integer;
  231.   Attr : byte;
  232.  
  233. begin
  234.   Attr := ComputeAttr(HFC,HBC);
  235.   for i := col to (col + width) do
  236.     begin
  237.       MoveFromScreen(p^[row,i],j,2);
  238.       j := (Attr shl 8) + Lo(j);
  239.       MoveToScreen(j,p^[row,i],2)
  240.     end
  241. end;
  242.  
  243.  
  244. procedure DrawBox(p : ScreenBufPtr;
  245.                   UpLeftX,
  246.                   UpLeftY,
  247.                   LowRightX,
  248.                   LowRightY : byte;
  249.                   FG,BorBG,IntBG : byte);
  250.  
  251. var
  252.   i,j : integer;
  253.   Attr : byte;
  254.  
  255. begin
  256.   Attr := ComputeAttr(FG,BorBG);
  257.   WriteAt(p,UpLeftX,UpLeftY,'I',Attr);
  258.   for i := (UpLeftY + 1) to (LowRightY - 1) do
  259.     WriteAt(p,UpLeftX,i,'M',Attr);
  260.   WriteAt(p,UpLeftX,i+1,';',Attr);
  261.   for i := (UpLeftX + 1) to (LowRightX - 1) do
  262.       begin
  263.         WriteAt(p,i,UpLeftY,':',Attr);
  264.         WriteAt(p,i,LowRightY,':',Attr);
  265.       end;
  266.   WriteAt(p,LowRightX,UpLeftY,'H',Attr);
  267.   for i := (UpLeftY + 1) to (LowRightY - 1) do
  268.     WriteAt(p,LowRightX,i,'M',Attr);
  269.   WriteAt(p,LowRightX,LowRightY,'<',Attr);
  270.  
  271.   for i := (UpLeftX + 1) to (LowRightX - 1) do
  272.     for j := (UpLeftY + 1) to (LowRightY - 1) do
  273.       WriteAt(p,i,j,' ',IntBg)
  274.  
  275. end;
  276.  
  277.  
  278. procedure MakeWindow(p : ScreenBufPtr;
  279.                      Ulx,Uly,Lrx,Lry,WindFG,WindBG : byte);
  280.  
  281. var
  282.   i,j : byte;
  283.   k : integer;
  284.  
  285. begin
  286.   OldX := WhereX;
  287.   OldY := WhereY;
  288.   k := DefBGColor shl 12;
  289.   for i := Ulx to Lrx do
  290.     begin
  291.       MoveFromScreen(VideoSeg^[i,Uly],p^[i,Uly],(Lry-Uly+1)*2);
  292.       for j := Uly to Lry do
  293.         MoveToScreen(k,VideoSeg^[i,j],2);
  294.     end;
  295.   DrawBox(VideoSeg,Ulx,Uly,Lrx,Lry,WindFG,WindBG,WindBG);
  296.   Window(Uly+2,Ulx+1,Lry-2,Lrx-1);
  297.   GotoXY(1,1)
  298. end;
  299.  
  300.  
  301. procedure RestoreWindow(p : ScreenBufPtr;
  302.                         Ulx,Uly,Lrx,Lry : byte);
  303.  
  304. var
  305.   i,j : byte;
  306.  
  307. begin
  308.   for i := Ulx to Lrx do
  309.     MoveFromScreen(p^[i,Uly],VideoSeg^[i,Uly],(Lry-Uly+1)*2);
  310.   Window(1,1,80,25);
  311.   GotoXY(OldX,OldY);
  312. end;
  313.  
  314.  
  315. { short demo program follows: }
  316.  
  317. begin
  318.   ClrScr;
  319.  
  320.   new(TempScreen);   { Allocate memory for screen buffer }
  321.   GetVideoSegment;   { Set video segment }
  322.  
  323.   TempAttr := ComputeAttr(Yellow,Blue);
  324.  
  325.   write('Write a B at 10,10;  Press any key to continue...');
  326.   WriteAt(VideoSeg,10,10,'B',TempAttr);
  327.  
  328.   repeat until keypressed;
  329.  
  330.   ClrScr;
  331.  
  332.   CursorOff;
  333.   writeln('Turn the cursor off; press any key...');
  334.   repeat until keypressed;
  335.   write('Then back on again; press any key...');
  336.   CursorOn;
  337.  
  338.   repeat until keypressed;
  339.  
  340.   ClrScr;
  341.  
  342.   writeln('Write a string at any place on the screen:');
  343.   writeln('Surround any part of the string with the tilde (~) character');
  344.   writeln('to have it appear in the highlighted color.');
  345.  
  346.   WriteStrAt(VideoSeg,10,10,
  347.              'This is a ~test~ string.  Press ~any~ key to continue.',
  348.              Blue,Yellow,Black,White);
  349.  
  350.   repeat until keypressed;
  351.  
  352.   ClrScr;
  353.   writeln('Center a string at any line on the screen:');
  354.   writeln('Again, surround any part of the string with the tilde (~) character');
  355.   writeln('to have it appear in the highlighted color.');
  356.  
  357.   CenterStrAt(VideoSeg,20,
  358.              'This is a ~test~ string.  Press ~any~ key to continue.',
  359.              Blue,Yellow,Black,White);
  360.  
  361.   repeat until keypressed;
  362.  
  363.   ClrScr;
  364.   writeln('You can highlight a bar on the screen, too: ');
  365.   write('Press any key to continue...');
  366.  
  367.   WriteStrAt(VideoSeg,10,10,'Highlighted!!',Blue,Yellow,Black,White);
  368.   HiLiteBar(VideoSeg,10,10,15,Black,White);
  369.  
  370.   repeat until keypressed;
  371.  
  372.   MakeWindow(TempScreen,2,5,10,60,White,Green);
  373.  
  374.   writeln('Now we are inside a window');
  375.   write('Press any key to make window disappear...');
  376.  
  377.   repeat until keypressed;
  378.  
  379.   RestoreWindow(TempScreen,2,5,10,60);
  380.  
  381.   delay(1500);
  382.  
  383.   dispose(tempscreen)     { Deallocate memory }
  384. end.
  385.